home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / NEWSOFT / AUGUST / WORKDISC / !Forthmacs / lib / blockio < prev    next >
Text File  |  1997-02-10  |  1KB  |  46 lines
  1. \ The low level I/O used to implement standard Forth BLOCKs
  2.  
  3. decimal
  4. system definitions
  5. 20 constant max#files
  6.  
  7. : open-block-file    ( str -- fid )
  8.     read fopen dup 0= if d# -275 throw then ;
  9.  
  10. nuser default-block-fid         \ File referenced by block-fid=0
  11. 0 default-block-fid !
  12.  
  13. : map-fid    ( fid -- fid' )
  14.     ?dup  0=
  15.     if    default-block-fid @  0=
  16.         if    p" forth.blk"  open-block-file  default-block-fid !
  17.         then
  18.         default-block-fid @
  19.     then ;
  20.  
  21. \ Seek to the correct starting address and prepare the arguments
  22. \ to the gem read or write call
  23. : setio        ( address block# fid -- address b/buf fid )
  24.     map-fid                        ( address block# fid' )
  25.     swap b/buf *  over fseek       ( address fid )
  26.     b/buf swap ;
  27.  
  28. : ?disk-abort    ( #transferred -- )    b/buf <> if d# -37 throw then  ;
  29. : (read-block)    ( addr blk# file -- )    setio fgets  ?disk-abort  ;
  30. : (write-block)    ( addr blk# file -- )    setio fputs  ;
  31.  
  32. : install-block-io    ( -- )
  33.     ['] (read-block)  is read-block
  34.     ['] (write-block) is write-block
  35.     0 default-block-fid ! ;
  36. install-block-io
  37. forth definitions
  38. : (cold-hook    (cold-hook install-block-io  ;
  39.     ' (cold-hook is cold-hook
  40.  
  41. \ Seek to end to find size
  42. : file-size    ( fid -- l )    map-fid  fsize  ;
  43. : .file        ( fid -- )    drop ." File name unknown"  ;
  44.  
  45. forth definitions
  46.